home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Fritz: All Fritz
/
All Fritz.zip
/
All Fritz
/
FILES
/
UTILFILE
/
HARDUTL2.LZH
/
DIR2.BAS
< prev
next >
Wrap
BASIC Source File
|
1983-11-27
|
21KB
|
513 lines
10 ' *** DIR.BAS *** IBM Version 2.00 ***
20 ' August 1983
30 '
40 ' Written by Wes Meier (70215,1017)
50 ' 230 B Park Lake Circle
60 ' Walnut Creek, CA 94598
70 '
80 ' Will work with DOS 1.10 or 2.00
90 '
100 ' Notes on Version 2.00:
110 ' ----------------------
120 ' 1 - Version 2.00 requires BASICA but does NOT use any of its
130 ' new commands, so DIR 2.00 should compile satifactorily.
140 '
150 ' 2 - The List File to Lineprinter routine has been implemented. This
160 ' routine uses only "plain vanilla" printer statements. Prints at
170 ' 10 cpi and 6 lpi. 150 files per page. Pages are numbered.
180 '
190 ' 3 - Version 2.00 does NOT support paths or alternate directories.
200 '
210 ' 4 - Version 2.00 will NOT allow you to "read" the directory of drive C:
220 ' into the list file. This is due to the way I execute the FILES
230 ' statement and then read the screen into memory. If drive C: is a
240 ' hard disk (which it usually is) there would be too many files for
250 ' the screen to handle without scrolling.
260 '
270 ' 5 - Version 2.00 will now function on either type of monitor. 80 column
280 ' is still required.
290 '
300 ' 6 - Version 2.00 will directly compile with the /E option.
310 '
320 ' ****************************************************************
330 ' * *** For Public Domain....Private Sales Rights Reserved ! *** *
340 ' ****************************************************************
350 '
360 DEFINT B-Z:DEFSTR A
370 AV=CHR$(34):AL=STRING$(80,196):AQ="("+AV+"*"+AV+" to QUIT) "
380 TRUE=-1:FALSE=NOT TRUE:AFORMAT="\ \ \ \ "
390 ' Check for monochrome monitor.
400 DEF SEG=0
410 IF (PEEK(&H410) AND &H30)=&H30 THEN MONOCHROME=TRUE ELSE MONOCHROME=FALSE
420 DEF SEG
430 DIM A(1000)
440 KEY OFF:WIDTH 40:SCREEN 0,1:COLOR 4,3,3:CLS
450 LOCATE 9,7,0,0,7:PRINT CHR$(201)STRING$(28,205)CHR$(187)
460 PRINT TAB(7) CHR$(186)SPC(3)"*** Disk Directory *** "CHR$(186)
470 PRINT TAB(7) CHR$(186)SPC(3)" *** Version 2.00 *** "CHR$(186)
480 PRINT TAB(7) CHR$(186)SPC(3)" *** August 1983 *** "CHR$(186)
490 PRINT TAB(7) CHR$(186)SPC(3)" *** By Wes Meier *** "CHR$(186)
500 PRINT TAB(7)CHR$(204)STRING$(28,205)CHR$(185)
510 PRINT TAB(7)CHR$(186)SPC(2)"Reading: "AV SPC(15)AV CHR$(186)
520 PRINT TAB(7)CHR$(200)STRING$(28,205)CHR$(188)
530 '
540 ' Check for DOS 1.10. "WINDOW=0" will cause error if 2.00.
550 ' When compiled, version 2.00 "thinks" its under DOS 1.10.
560 '
570 ON ERROR GOTO 600
580 WINDOW=0:DOS1.1=TRUE
590 GOTO 610
600 IF ERL=580 THEN DOS1.1=FALSE:RESUME 610
610 ON ERROR GOTO 630
620 GOTO 660
630 IF ERR=53 THEN RESUME 640 ELSE ON ERROR GOTO 0
640 CLOSE:OPEN "O",1,"DIR.DAT":CLOSE
650 ON ERROR GOTO 0
660 OPEN "I",1,"DIR.DAT"
670 FOR X=1 TO 1000
680 IF EOF(1)THEN CLOSE:GOTO 720 ELSE INPUT #1,A(X):ENTRIES=ENTRIES+1
690 LOCATE 15,20,0:PRINT A(X);
700 NEXT
710 CLOSE
720 ' ************
730 ' **** MENU ****
740 ' ************
750 IF SORTFLAG THEN GOSUB 5040
760 IF MONOCHROME THEN COLOR 7 ELSE IF PAGE THEN COLOR ,,1:SCREEN ,,1,1:GOTO 1320
770 WIDTH 80:SCREEN 0,1,1,1:COLOR ,1,1:PAGE=TRUE
780 CLS
790 COLOR 6
800 LOCATE 5,1,0
810 PRINT CHR$(201)STRING$(78,205)CHR$(187);
820 PRINT CHR$(186);
830 COLOR 13
840 PRINT TAB(13)"*** DISK DIRECTORY *** MENU ****";
850 PRINT ENTRIES"ENTRIES ON RECORD ***";
860 COLOR 6
870 PRINT TAB(80)CHR$(186);
880 PRINT CHR$(204)STRING$(78,205)CHR$(185);
890 PRINT CHR$(186)TAB(13);
900 COLOR 3:PRINT"Enter:"TAB(80):COLOR 6:PRINT CHR$(186);
910 PRINT CHR$(186)TAB(19);
920 COLOR 27:PRINT"1. ";:COLOR 3
930 PRINT"To FIND an item."TAB(80);
940 COLOR 6:PRINT CHR$(186);
950 PRINT CHR$(186)TAB(19);
960 COLOR 27:PRINT"2. ";:COLOR 3
970 PRINT"To ENTER an item or an entire disk."TAB(80);
980 COLOR 6:PRINT CHR$(186);
990 PRINT CHR$(186)TAB(19);
1000 COLOR 27:PRINT"3. ";:COLOR 3
1010 PRINT"To DELETE an item or an entire disk."TAB(80);
1020 COLOR 6:PRINT CHR$(186);
1030 PRINT CHR$(186)TAB(19);
1040 COLOR 27:PRINT"4. ";:COLOR 3
1050 PRINT"To LIST the file to the CRT or the PRINTER."TAB(80);
1060 COLOR 6:PRINT CHR$(186);
1070 PRINT CHR$(186)TAB(19);
1080 COLOR 27:PRINT"5. ";:COLOR 3
1090 PRINT"To LIST the directory of a disk."TAB(80);
1100 COLOR 6:PRINT CHR$(186);
1110 PRINT CHR$(186)TAB(19);
1120 COLOR 27:PRINT"6. ";:COLOR 3
1130 PRINT"To BACKUP the data file."TAB(80);
1140 COLOR 6:PRINT CHR$(186);
1150 PRINT CHR$(186)TAB(19);
1160 COLOR 27:PRINT"";:COLOR 3
1170 PRINT""TAB(80);
1180 COLOR 6:PRINT CHR$(186);
1190 PRINT CHR$(186)TAB(19);
1200 COLOR 27:PRINT"";:COLOR 3
1210 PRINT""TAB(80);
1220 COLOR 6:PRINT CHR$(186);
1230 PRINT CHR$(186)TAB(19);
1240 COLOR 27:PRINT"9. ";:COLOR 3
1250 PRINT"To RETURN to DOS."TAB(80);
1260 COLOR 6:PRINT CHR$(186);
1270 PRINT CHR$(204)STRING$(78,205)CHR$(185);
1280 PRINT CHR$(186)TAB(27);
1290 COLOR 20,7:PRINT" *** ENTER YOUR CHOICE *** ";
1300 COLOR 6,1:PRINT TAB(80)CHR$(186);
1310 PRINT CHR$(200)STRING$(78,205)CHR$(188);
1320 BEEP
1330 CHOICE$="":WHILE CHOICE$="":CHOICE$=INKEY$:WEND
1340 CHOICE=INSTR("123456789",CHOICE$)
1350 IF CHOICE=0 THEN 1320
1360 SCREEN ,,0,0:COLOR 6,1,1:CLS
1370 ' 1 2 3 4 5 6 7 8 9
1380 ON CHOICE GOTO 1390,1790,2590,3020,3650,4050,750,750,4620
1390 '****************************************
1400 '* *** Find an ITEM routine *** *
1410 '****************************************
1420 COLOR ,3,3:CLS
1430 COLOR 16:PRINT AL;:COLOR 1
1440 PRINT TAB(26)"*** FIND AN ITEM ROUTINE ***"
1450 COLOR 16:PRINT AL
1460 COLOR 4:PRINT"Enter complete or partial ";
1470 PRINT"filespec of ITEM to be found "AQ"........"
1480 COLOR 1:INPUT AT:IF AT="*" THEN 720' Return to menu.
1490 ACAP=AT:GOSUB 5230:AT=ACAP
1500 FOR X=1 TO ENTRIES
1510 IF INSTR(A(X),AT)=0 OR LEFT$(A(X),12)=LEFT$(AX,12) THEN 1600
1520 AX=A(X)
1530 PRINT AV;LEFT$(A(X),12);AV" can be found on disks: ";
1540 FOR Y=X TO ENTRIES
1550 IF LEFT$(AX,12)=LEFT$(A(Y),12) THEN PRINT RIGHT$(A(Y),3)", ";:GOTO 1570
1560 Y=ENTRIES
1570 NEXT
1580 PRINT:PRINT:PRINT"Is this the ITEM you wanted to find ";
1590 GOSUB 4770:IF ANSWER="Y"THEN 1620
1600 NEXT:PRINT:PRINT"I cannot locate any incidence of "AV;AT;AV". Try again."
1610 PRINT:GOTO 1460
1620 PRINT:PRINT"Do you want to RUN "AV;AX;AV" ";
1630 GOSUB 4770:IF ANSWER="N" THEN 720
1640 ON ERROR GOTO 1660
1650 GOTO 1670
1660 IF ERR=53 THEN RESUME 1680 ELSE ON ERROR GOTO 0
1670 IF MID$(AX,10,3)="BAS" THEN RUN "A:"+LEFT$(AX,12) ELSE 1750
1680 ON ERROR GOTO 1690:RUN "B:"+LEFT$(AX,12)
1690 IF ERR=53 THEN RESUME 1700 ELSE ON ERROR GOTO 0
1700 COLOR 4:PRINT:BEEP:BEEP:PRINT"I cannot locate "AV;AX;AV;
1710 PRINT" on either drive "AV"A"AV" or drive "AV"B"AV"!!!"
1720 PRINT"Please check to see that Disk #";
1730 PRINT RIGHT$(AX,3)" is mounted and press any"
1740 PRINT"key to continue ";:COLOR 1:GOSUB 4700:PRINT:GOTO 1620
1750 PRINT:PRINT"Since "AV;AX;AV" doesn't have the "AV".BAS"AV" extension,";
1760 PRINT "I can't RUN it!"
1770 PRINT"Press any key to return to the menu...("AV"*"AV" to jump to DOS) ";
1780 GOSUB 4670:IF ANSWER<>"*"THEN 720 ELSE CLS:SYSTEM
1790 '****************************
1800 '**** ITEM ENTRY ROUTINE ****
1810 '****************************
1820 COLOR 4,7,7:CLS
1830 COLOR 1:PRINT AL;:COLOR 4
1840 PRINT TAB(27)"*** Item Entry Routine ***"
1850 COLOR 1:PRINT AL:COLOR 4
1860 LOCATE 12,1
1870 PRINT"Do you want to enter from the ";:COLOR 17:PRINT"K";:COLOR 4
1880 PRINT "eyboard or read a ";:COLOR 17:PRINT "D";:COLOR 4:PRINT "isk "AQ;
1890 COLOR 1
1900 GOSUB 4670:COLOR 4
1910 IF ANSWER="*"THEN 720 ELSE IF ANSWER="k" OR ANSWER="K" THEN 1940
1920 IF ANSWER="D" OR ANSWER="d" THEN 2130
1930 LOCATE L,T:BEEP:GOTO 1900
1940 ' Keyboard item entry routine
1950 LOCATE 12,1:PRINT SPACE$(79)
1960 LOCATE 4,1
1970 PRINT AV".BAS"AV" is the default extension."
1980 PRINT "Enter filespec "AQ;:INPUT A:IF A="*"THEN 720
1990 ACAP=A:GOSUB 5230:A=ACAP
2000 IF LEN(A)>12 THEN BEEP:PRINT A" is too long !":GOTO 1980
2010 INPUT "Enter disk # ";AD
2020 IF VAL(AD)<1 OR VAL(AD)>999 THEN BEEP:GOTO 2010
2030 AD=RIGHT$("00"+AD,3)
2040 K=INSTR(A,".")
2050 IF K=0 THEN A=LEFT$(A+" ",8)+".BAS":GOTO 2040
2060 A=LEFT$(MID$(A,1,K-1)+" ",8)+RIGHT$(A,LEN(A)-(K-1))
2070 A=LEFT$(A+" ",12)+AD
2080 PRINT"Is "AV;A;AV" correct ";
2090 GOSUB 4770:IF ANSWER$="N"THEN 1980
2100 ENTRIES=ENTRIES+1
2110 A(ENTRIES)=A:A="":PRINT"Entered. Do you have any more entries ";
2120 GOSUB 4770:IF ANSWER="N"THEN GOSUB 5010:GOSUB 4960:RUN ELSE 1970
2130 'Read disk entry routine
2140 LOCATE 12,1:PRINT SPACE$(79)
2150 LOCATE 4,1
2160 PRINT "Enter disk number to be read "AQ;
2170 INPUT ADISK:IF ADISK="*"THEN 720 ELSE DISK=VAL (ADISK)
2180 IF DISK<0 OR DISK>999 THEN BEEP:GOTO 2160
2190 ADISK=STR$(DISK):MID$(ADISK,1)="0":ADISK=RIGHT$("00"+ADISK,3)
2200 PRINT "Enter drive (A or B) (B is the default) ";
2210 GOSUB 4670:ADRIVE=ANSWER$:IF ADRIVE=CHR$(13) THEN ADRIVE="B":GOTO 2240
2220 ACAP=ADRIVE:GOSUB 5230:ADRIVE=ACAP
2230 IF ADRIVE<>"A" AND ADRIVE<>"B" THEN LOCATE L,T:BEEP:GOTO 2210
2240 LOCATE L,T:PRINT "? "ADRIVE
2250 PRINT:PRINT"Read disk #"ADISK" on drive "AV;ADRIVE;AV". Is this correct ";
2260 GOSUB 4770:IF ANSWER="N"THEN 2160
2270 PRINT"Deleting references to disk #"ADISK"......"
2280 FOR X=1 TO ENTRIES
2290 IF RIGHT$(A(X),3)=ADISK THEN A(X)=""
2300 NEXT
2310 ' ******************************************
2320 ' ***** Routine to Read a Disk's Directory **DIR2 BASC4 112783 21376.
******
2340 CLS
2350 PRINT AL;
2360 IF ADRIVE="A"THEN FILES"A:*.*" ELSE FILES "B:*.*"
2370 PRINT:PRINT AL;
2380 ROW=CSRLIN:COL=POS(0):COLOR 6,1
2390 IF DOS1.1 THEN STLIN=2 ELSE STLIN=3
2400 IF DOS1.1 THEN ENDPT=78:STEPPT=13 ELSE ENDPT=69:STEPPT=18
C2